#############################
CheckVals <- function(x, okay, na.rm = TRUE) {
  cx <- class(x)
  if (!is.vector(x)) {
    if (is.list(x)) {
      x <- unlist(x)
    } else if (is.matrix(x) || is.array(x)) {
      x <- as.vector(x)
    }
  }
  if (!is.vector(x)) stop(cx, " is not a valid class for this function")

  '%nin%' <- function(x, table) !.Internal(match(x, table, 0L, NULL)) > 0L

  if (na.rm) okay <- c(okay, NA)

  nm <- x[x %nin% okay]
  if (length(nm) > 0)
    stop("\nThe following values are not valid: \n[", paste(nm, collapse = ", "), "]")

  return(TRUE)
}


NormDF <- function(data, continuous = c("mean", "median", "zero"),
  discrete = c("mode", "lowest", "highest")) {

  continuous <- match.arg(continuous)
  discrete <- match.arg(discrete)

  cFUN <- switch(continuous,
    "mean" = mean,
    "median" = median,
    "zero" = function(...) 0)
  dFUN <- switch(discrete,
    "mode" = function(x) {
      y <- names(sort.int(table(x, useNA = "no"), decreasing = TRUE))[1L]
      if (is.factor(x)) y <- factor(y, levels = levels(x), ordered = is.ordered(x))
      if (is.logical(x)) y <- as.logical(y)
      return(y)
    },
    "lowest" = function(x) {
      if (is.factor(x)) {
        y <- factor(levels(x)[1L], levels = levels(x), ordered = is.ordered(x))
      } else y <- sort(x)[1L]
      if (is.logical(x)) y <- as.logical(y)
      return(y)
    },
    "highest" = function(x) {
      if (is.factor(x)) {
        y <- factor(levels(x)[length(levels(x))], levels = levels(x), ordered = is.ordered(x))
      } else y <- sort(x)[length(x)]
      if (is.logical(x)) y <- as.logical(y)
      return(y)
    })

  as.data.frame(lapply(data, function(x) {
    if (is.numeric(x)) {cFUN(x, na.rm = TRUE)
    } else if(any(is.factor(x), is.logical(x), is.character(x))) {
      dFUN(x)
    } else stop("Class: '", class(x), "' is currently unsupported")
  }), stringsAsFactors = FALSE)
}

## Short function to print date and parts of sessionInfo
## in HTML style
buildInfo <- function() {
  d <- Sys.Date()
  out <- paste("Built on: ", d, "<br />\nUnder: ", R.version.string,
    "<br />\n", sep = '')
  x <- sessionInfo()
  if (length(x$otherPkgs)) {
    x <- sapply(x$otherPkgs, function(x) x$Version)
    x <- paste(paste(names(x), x), collapse = "; ")
    out <- paste(out, "With: ", x, "\n", sep = '')
  }
  return(out)
}

## build matrix from simple text
## accepts combo of numbers and symbols
buildMatrix <- function(text, eval = TRUE) {
  env <- parent.frame()
  dat <- as.matrix(read.table(text = text, header = FALSE,
    colClasses = "character"))
  d <- dim(dat)
  stopifnot(all.equal(d[1], d[2]))
  results <- numMat <- suppressWarnings(as.numeric(dat))
  index <- which(is.na(numMat))
  sym <- parse(text = dat[index])

  if (eval) {
    sym <- sapply(sym, eval, envir = env)
    results[index] <- sym
    dim(results) <- d
    return(results)
  } else {
    results[index] <- sym
    return(list(results = results, dims = d))
  }
}

## function to evaluate a saved matrix
matEval <- function(x) {
  env <- parent.frame()
  results <- sapply(x[[1]], eval, envir = env)
  dim(results) <- x[[2]]
  return(results)
}

if (FALSE) {
## some values for the symbols
a <- 2
b <- 5
c <- 1
d <- 0
e <- 6

## an example matrix
sigma <- buildMatrix("
a^2  0  c
0  b  d
c  d  e
")
}

## convert correlations + variances to covariances
cor2cov <- function(V, sigma) {
  p <- (d <- dim(V))[1L]
  if (!is.numeric(V) || length(d) != 2L || p != d[2L])
      stop("'V' is not a square numeric matrix")
  if (length(sigma) != p)
      stop("'sigma' is not a vector comformable as the standard deviations of 'V'")
  if (any(diag(V) != 1))
      warning("diag(.) contained non 1 entries.  Did you pass a correlation matrix?")
  sigma * V * rep(sigma, each = p)
}

## In development
## Need to find a way to substitute in the object values
## if objects or if things like 1:5 evaluate or if character
## then leave as is
if (FALSE) {
lops <- function(e1, e2, operator = "==", env = parent.frame()) {
  op <- match.fun(operator)
  ## split on operators
  myops <- "&|&&|\\||\\|\\|"
  tmp <- unlist(strsplit(e2, myops))
  ## strip whitespace
  tmp <- gsub("[[:space:]]", "", tmp)
  tmp2 <- lapply(tmp, function(x) try(get(x, envir = env), TRUE))
  index <- sapply(tmp2, inherits, "try-error")
  tmp2[index] <- tmp[index]
  tres <- lapply(tmp2, function(x) op(e1, x))
  names(tres) <- tmp
  mycall <- paste("substitute(expression(", e2, "), tres)", sep = '')
  output <- eval(parse(text = mycall))
  results <- eval(eval(output))
  return(results)
}

debug(lops)
lops(e, "a | b | d")

a <- 1:5
b <- c(2:3, 3:5)
d <- c(1:3, 5:6)
e <- c(1, 3:6)

cbind(a, b, d, e)

`%==%` <- function(e1, e2) {
   e2 <- as.character(as.expression(substitute(e2)))
   e2 <- gsub("\\(|\\)", "", e2)
   env <- parent.frame()
   results <- lops(e1 = e1, e2 = e2, operator = "==",
     env = parent.frame())
   return(results)
}

}
